home *** CD-ROM | disk | FTP | other *** search
/ Amiga Format CD 41 / Amiga Format CD41 (1999-06)(Future Publishing)(GB)[!][issue 1999-07].iso / -seriously_amiga- / programming / other / scm / slib / r4rsyn.scm < prev    next >
Text File  |  1999-04-19  |  17KB  |  543 lines
  1. ;;; "r4rsyn.scm" R4RS syntax        -*-Scheme-*-
  2. ;;; Copyright (c) 1989-91 Massachusetts Institute of Technology
  3. ;;;
  4. ;;; This material was developed by the Scheme project at the
  5. ;;; Massachusetts Institute of Technology, Department of Electrical
  6. ;;; Engineering and Computer Science.  Permission to copy this
  7. ;;; software, to redistribute it, and to use it for any purpose is
  8. ;;; granted, subject to the following restrictions and understandings.
  9. ;;;
  10. ;;; 1. Any copy made of this software must include this copyright
  11. ;;; notice in full.
  12. ;;;
  13. ;;; 2. Users of this software agree to make their best efforts (a) to
  14. ;;; return to the MIT Scheme project any improvements or extensions
  15. ;;; that they make, so that these may be included in future releases;
  16. ;;; and (b) to inform MIT of noteworthy uses of this software.
  17. ;;;
  18. ;;; 3. All materials developed as a consequence of the use of this
  19. ;;; software shall duly acknowledge such use, in accordance with the
  20. ;;; usual standards of acknowledging credit in academic research.
  21. ;;;
  22. ;;; 4. MIT has made no warrantee or representation that the operation
  23. ;;; of this software will be error-free, and MIT is under no
  24. ;;; obligation to provide any services, by way of maintenance, update,
  25. ;;; or otherwise.
  26. ;;;
  27. ;;; 5. In conjunction with products arising from the use of this
  28. ;;; material, there shall be no use of the name of the Massachusetts
  29. ;;; Institute of Technology nor of any adaptation thereof in any
  30. ;;; advertising, promotional, or sales literature without prior
  31. ;;; written consent from MIT in each case.
  32.  
  33. ;;;; R4RS Syntax
  34.  
  35. (define scheme-syntactic-environment #f)
  36.  
  37. (define (initialize-scheme-syntactic-environment!)
  38.   (set! scheme-syntactic-environment
  39.     ((compose-macrologies
  40.       (make-core-primitive-macrology)
  41.       (make-binding-macrology syntactic-binding-theory
  42.                   'LET-SYNTAX 'LETREC-SYNTAX 'DEFINE-SYNTAX)
  43.       (make-binding-macrology variable-binding-theory
  44.                   'LET 'LETREC 'DEFINE)
  45.       (make-r4rs-primitive-macrology)
  46.       (make-core-expander-macrology)
  47.       (make-syntax-rules-macrology))
  48.      root-syntactic-environment)))
  49.  
  50. ;;;; Core Primitives
  51.  
  52. (define (make-core-primitive-macrology)
  53.   (make-primitive-macrology
  54.    (lambda (define-classifier define-compiler)
  55.  
  56.      (define-classifier 'BEGIN
  57.        (lambda (form environment definition-environment)
  58.      (syntax-check '(KEYWORD * FORM) form)
  59.      (make-body-item (classify/subforms (cdr form)
  60.                         environment
  61.                         definition-environment))))
  62.  
  63.      (define-compiler 'DELAY
  64.        (lambda (form environment)
  65.      (syntax-check '(KEYWORD EXPRESSION) form)
  66.      (output/delay
  67.       (compile/subexpression (cadr form)
  68.                  environment))))
  69.  
  70.      (define-compiler 'IF
  71.        (lambda (form environment)
  72.      (syntax-check '(KEYWORD EXPRESSION EXPRESSION ? EXPRESSION) form)
  73.      (output/conditional
  74.       (compile/subexpression (cadr form) environment)
  75.       (compile/subexpression (caddr form) environment)
  76.       (if (null? (cdddr form))
  77.           (output/unspecific)
  78.           (compile/subexpression (cadddr form)
  79.                      environment)))))
  80.  
  81.      (define-compiler 'QUOTE
  82.        (lambda (form environment)
  83.      environment            ;ignore
  84.      (syntax-check '(KEYWORD DATUM) form)
  85.      (output/literal-quoted (strip-syntactic-closures (cadr form))))))))
  86.  
  87. ;;;; Bindings
  88.  
  89. (define (make-binding-macrology binding-theory
  90.                 let-keyword letrec-keyword define-keyword)
  91.   (make-primitive-macrology
  92.    (lambda (define-classifier define-compiler)
  93.  
  94.      (let ((pattern/let-like
  95.         '(KEYWORD (* (IDENTIFIER EXPRESSION)) + FORM))
  96.        (compile/let-like
  97.         (lambda (form environment body-environment output/let)
  98.           ;; Force evaluation order.
  99.           (let ((bindings
  100.              (let loop
  101.              ((bindings
  102.                (map (lambda (binding)
  103.                   (cons (car binding)
  104.                     (classify/subexpression
  105.                      (cadr binding)
  106.                      environment)))
  107.                 (cadr form))))
  108.                (if (null? bindings)
  109.                '()
  110.                (let ((binding
  111.                   (binding-theory body-environment
  112.                           (caar bindings)
  113.                           (cdar bindings))))
  114.                  (if binding
  115.                  (cons binding (loop (cdr bindings)))
  116.                  (loop (cdr bindings))))))))
  117.         (output/let (map car bindings)
  118.                 (map (lambda (binding)
  119.                    (compile-item/expression (cdr binding)))
  120.                  bindings)
  121.                 (compile-item/expression
  122.                  (classify/body (cddr form)
  123.                         body-environment)))))))
  124.  
  125.        (define-compiler let-keyword
  126.      (lambda (form environment)
  127.        (syntax-check pattern/let-like form)
  128.        (compile/let-like form
  129.                  environment
  130.                  (internal-syntactic-environment environment)
  131.                  output/let)))
  132.  
  133.        (define-compiler letrec-keyword
  134.      (lambda (form environment)
  135.        (syntax-check pattern/let-like form)
  136.        (let ((environment (internal-syntactic-environment environment)))
  137.          (reserve-names! (map car (cadr form)) environment)
  138.          (compile/let-like form
  139.                    environment
  140.                    environment
  141.                    output/letrec)))))
  142.  
  143.      (define-classifier define-keyword
  144.        (lambda (form environment definition-environment)
  145.      (syntax-check '(KEYWORD IDENTIFIER EXPRESSION) form)
  146.      (syntactic-environment/define! definition-environment
  147.                     (cadr form)
  148.                     (make-reserved-name-item))
  149.      (make-definition-item binding-theory
  150.                    (cadr form)
  151.                    (make-promise
  152.                 (lambda ()
  153.                   (classify/subexpression
  154.                    (caddr form)
  155.                    environment)))))))))
  156.  
  157. ;;;; Bodies
  158.  
  159. (define (classify/body forms environment)
  160.   (let ((environment (internal-syntactic-environment environment)))
  161.     (let forms-loop
  162.     ((forms forms)
  163.      (bindings '()))
  164.       (if (null? forms)
  165.       (syntax-error "no expressions in body"
  166.             "")
  167.       (let items-loop
  168.           ((items
  169.         (item->list
  170.          (classify/subform (car forms)
  171.                    environment
  172.                    environment)))
  173.            (bindings bindings))
  174.         (cond ((null? items)
  175.            (forms-loop (cdr forms)
  176.                    bindings))
  177.           ((definition-item? (car items))
  178.            (items-loop (cdr items)
  179.                    (let ((binding
  180.                       (bind-definition-item! environment
  181.                                  (car items))))
  182.                  (if binding
  183.                      (cons binding bindings)
  184.                      bindings))))
  185.           (else
  186.            (let ((body
  187.               (make-body-item
  188.                (append items
  189.                    (flatten-body-items
  190.                     (classify/subforms
  191.                      (cdr forms)
  192.                      environment
  193.                      environment))))))
  194.              (make-expression-item
  195.               (lambda ()
  196.             (output/letrec
  197.              (map car bindings)
  198.              (map (lambda (binding)
  199.                 (compile-item/expression (cdr binding)))
  200.                   bindings)
  201.              (compile-item/expression body))) forms)))))))))
  202.  
  203. ;;;; R4RS Primitives
  204.  
  205. (define (make-r4rs-primitive-macrology)
  206.   (make-primitive-macrology
  207.    (lambda (define-classifier define-compiler)
  208.  
  209.      (define (transformer-keyword expander->classifier)
  210.        (lambda (form environment definition-environment)
  211.      definition-environment        ;ignore
  212.      (syntax-check '(KEYWORD EXPRESSION) form)
  213.      (let ((item
  214.         (classify/subexpression (cadr form)
  215.                     scheme-syntactic-environment)))
  216.        (let ((transformer (base:eval (compile-item/expression item))))
  217.          (if (procedure? transformer)
  218.          (make-keyword-item
  219.           (expander->classifier transformer environment) item)
  220.          (syntax-error "transformer not a procedure"
  221.                    transformer))))))
  222.  
  223.      (define-classifier 'TRANSFORMER
  224.        ;; "Syntactic Closures" transformer
  225.        (transformer-keyword sc-expander->classifier))
  226.  
  227.      (define-classifier 'ER-TRANSFORMER
  228.        ;; "Explicit Renaming" transformer
  229.        (transformer-keyword er-expander->classifier))
  230.  
  231.      (define-compiler 'LAMBDA
  232.        (lambda (form environment)
  233.      (syntax-check '(KEYWORD R4RS-BVL + FORM) form)
  234.      (let ((environment (internal-syntactic-environment environment)))
  235.        ;; Force order -- bind names before classifying body.
  236.        (let ((bvl-description
  237.           (let ((rename
  238.              (lambda (identifier)
  239.                (bind-variable! environment identifier))))
  240.             (let loop ((bvl (cadr form)))
  241.               (cond ((null? bvl)
  242.                  '())
  243.                 ((pair? bvl)
  244.                  (cons (rename (car bvl)) (loop (cdr bvl))))
  245.                 (else
  246.                  (rename bvl)))))))
  247.          (output/lambda bvl-description
  248.                 (compile-item/expression
  249.                  (classify/body (cddr form)
  250.                         environment)))))))
  251.  
  252.      (define-compiler 'SET!
  253.        (lambda (form environment)
  254.      (syntax-check '(KEYWORD FORM EXPRESSION) form)
  255.      (output/assignment
  256.       (let loop
  257.           ((form (cadr form))
  258.            (environment environment))
  259.         (cond ((identifier? form)
  260.            (let ((item
  261.               (syntactic-environment/lookup environment form)))
  262.              (if (variable-item? item)
  263.              (variable-item/name item)
  264.              (slib:error "target of assignment not a variable"
  265.                        form))))
  266.           ((syntactic-closure? form)
  267.            (let ((form (syntactic-closure/form form))
  268.              (environment
  269.               (filter-syntactic-environment
  270.                (syntactic-closure/free-names form)
  271.                environment
  272.                (syntactic-closure/environment form))))
  273.              (loop form
  274.                environment)))
  275.           (else
  276.            (slib:error "target of assignment not an identifier"
  277.                  form))))
  278.       (compile/subexpression (caddr form)
  279.                  environment))))
  280.  
  281.      ;; end MAKE-R4RS-PRIMITIVE-MACROLOGY
  282.      )))
  283.  
  284. ;;;; Core Expanders
  285.  
  286. (define (make-core-expander-macrology)
  287.   (make-er-expander-macrology
  288.    (lambda (define-expander base-environment)
  289.  
  290.      (let ((keyword (make-syntactic-closure base-environment '() 'DEFINE)))
  291.        (define-expander 'DEFINE
  292.      (lambda (form rename compare)
  293.        compare            ;ignore
  294.        (if (syntax-match? '((IDENTIFIER . R4RS-BVL) + FORM) (cdr form))
  295.            `(,keyword ,(caadr form)
  296.               (,(rename 'LAMBDA) ,(cdadr form) ,@(cddr form)))
  297.            `(,keyword ,@(cdr form))))))
  298.  
  299.      (let ((keyword (make-syntactic-closure base-environment '() 'LET)))
  300.        (define-expander 'LET
  301.      (lambda (form rename compare)
  302.        compare            ;ignore
  303.        (if (syntax-match? '(IDENTIFIER (* (IDENTIFIER EXPRESSION)) + FORM)
  304.                   (cdr form))
  305.            (let ((name (cadr form))
  306.              (bindings (caddr form)))
  307.          `((,(rename 'LETREC)
  308.             ((,name (,(rename 'LAMBDA) ,(map car bindings) ,@(cdddr form))))
  309.             ,name)
  310.            ,@(map cadr bindings)))
  311.            `(,keyword ,@(cdr form))))))
  312.  
  313.      (define-expander 'LET*
  314.        (lambda (form rename compare)
  315.      compare            ;ignore
  316.      (if (syntax-match? '((* (IDENTIFIER EXPRESSION)) + FORM) (cdr form))
  317.          (let ((bindings (cadr form))
  318.            (body (cddr form))
  319.            (keyword (rename 'LET)))
  320.            (if (null? bindings)
  321.            `(,keyword ,bindings ,@body)
  322.            (let loop ((bindings bindings))
  323.              (if (null? (cdr bindings))
  324.              `(,keyword ,bindings ,@body)
  325.              `(,keyword (,(car bindings))
  326.                     ,(loop (cdr bindings)))))))
  327.          (ill-formed-syntax form))))
  328.  
  329.      (define-expander 'AND
  330.        (lambda (form rename compare)
  331.      compare            ;ignore
  332.      (if (syntax-match? '(* EXPRESSION) (cdr form))
  333.          (let ((operands (cdr form)))
  334.            (if (null? operands)
  335.            `#T
  336.            (let ((if-keyword (rename 'IF)))
  337.              (let loop ((operands operands))
  338.                (if (null? (cdr operands))
  339.                (car operands)
  340.                `(,if-keyword ,(car operands)
  341.                      ,(loop (cdr operands))
  342.                      #F))))))
  343.          (ill-formed-syntax form))))
  344.  
  345.      (define-expander 'OR
  346.        (lambda (form rename compare)
  347.      compare            ;ignore
  348.      (if (syntax-match? '(* EXPRESSION) (cdr form))
  349.          (let ((operands (cdr form)))
  350.            (if (null? operands)
  351.            `#F
  352.            (let ((let-keyword (rename 'LET))
  353.              (if-keyword (rename 'IF))
  354.              (temp (rename 'TEMP)))
  355.              (let loop ((operands operands))
  356.                (if (null? (cdr operands))
  357.                (car operands)
  358.                `(,let-keyword ((,temp ,(car operands)))
  359.                       (,if-keyword ,temp
  360.                                ,temp
  361.                                ,(loop (cdr operands)))))))))
  362.          (ill-formed-syntax form))))
  363.  
  364.      (define-expander 'CASE
  365.        (lambda (form rename compare)
  366.      (if (syntax-match? '(EXPRESSION + (DATUM + EXPRESSION)) (cdr form))
  367.          (letrec
  368.          ((process-clause
  369.            (lambda (clause rest)
  370.              (cond ((null? (car clause))
  371.                 (process-rest rest))
  372.                ((and (identifier? (car clause))
  373.                  (compare (rename 'ELSE) (car clause))
  374.                  (null? rest))
  375.                 `(,(rename 'BEGIN) ,@(cdr clause)))
  376.                ((list? (car clause))
  377.                 `(,(rename 'IF) (,(rename 'MEMV) ,(rename 'TEMP)
  378.                                  ',(car clause))
  379.                         (,(rename 'BEGIN) ,@(cdr clause))
  380.                         ,(process-rest rest)))
  381.                (else
  382.                 (syntax-error "ill-formed clause" clause)))))
  383.           (process-rest
  384.            (lambda (rest)
  385.              (if (null? rest)
  386.              (unspecific-expression)
  387.              (process-clause (car rest) (cdr rest))))))
  388.            `(,(rename 'LET) ((,(rename 'TEMP) ,(cadr form)))
  389.                 ,(process-clause (caddr form) (cdddr form))))
  390.          (ill-formed-syntax form))))
  391.  
  392.      (define-expander 'COND
  393.        (lambda (form rename compare)
  394.      (letrec
  395.          ((process-clause
  396.            (lambda (clause rest)
  397.          (cond
  398.           ((or (not (list? clause))
  399.                (null? clause))
  400.            (syntax-error "ill-formed clause" clause))
  401.           ((and (identifier? (car clause))
  402.             (compare (rename 'ELSE) (car clause)))
  403.            (cond
  404.             ((or (null? (cdr clause))
  405.              (and (identifier? (cadr clause))
  406.                   (compare (rename '=>) (cadr clause))))
  407.              (syntax-error "ill-formed ELSE clause" clause))
  408.             ((not (null? rest))
  409.              (syntax-error "misplaced ELSE clause" clause))
  410.             (else
  411.              `(,(rename 'BEGIN) ,@(cdr clause)))))
  412.           ((null? (cdr clause))
  413.            `(,(rename 'OR) ,(car clause) ,(process-rest rest)))
  414.           ((and (identifier? (cadr clause))
  415.             (compare (rename '=>) (cadr clause)))
  416.            (if (and (pair? (cddr clause))
  417.                 (null? (cdddr clause)))
  418.                `(,(rename 'LET)
  419.              ((,(rename 'TEMP) ,(car clause)))
  420.              (,(rename 'IF) ,(rename 'TEMP)
  421.                     (,(caddr clause) ,(rename 'TEMP))
  422.                     ,(process-rest rest)))
  423.                (syntax-error "ill-formed => clause" clause)))
  424.           (else
  425.            `(,(rename 'IF) ,(car clause)
  426.                    (,(rename 'BEGIN) ,@(cdr clause))
  427.                    ,(process-rest rest))))))
  428.           (process-rest
  429.            (lambda (rest)
  430.          (if (null? rest)
  431.              (unspecific-expression)
  432.              (process-clause (car rest) (cdr rest))))))
  433.        (let ((clauses (cdr form)))
  434.          (if (null? clauses)
  435.          (syntax-error "no clauses" form)
  436.          (process-clause (car clauses) (cdr clauses)))))))
  437.  
  438.      (define-expander 'DO
  439.        (lambda (form rename compare)
  440.      compare            ;ignore
  441.      (if (syntax-match? '((* (IDENTIFIER EXPRESSION ? EXPRESSION))
  442.                   (+ EXPRESSION)
  443.                   * FORM)
  444.                 (cdr form))
  445.          (let ((bindings (cadr form)))
  446.            `(,(rename 'LETREC)
  447.          ((,(rename 'DO-LOOP)
  448.            (,(rename 'LAMBDA)
  449.             ,(map car bindings)
  450.             (,(rename 'IF) ,(caaddr form)
  451.                    ,(if (null? (cdaddr form))
  452.                     (unspecific-expression)
  453.                     `(,(rename 'BEGIN) ,@(cdaddr form)))
  454.                    (,(rename 'BEGIN)
  455.                     ,@(cdddr form)
  456.                     (,(rename 'DO-LOOP)
  457.                      ,@(map (lambda (binding)
  458.                           (if (null? (cddr binding))
  459.                           (car binding)
  460.                           (caddr binding)))
  461.                         bindings)))))))
  462.          (,(rename 'DO-LOOP) ,@(map cadr bindings))))
  463.          (ill-formed-syntax form))))
  464.  
  465.      (define-expander 'QUASIQUOTE
  466.        (lambda (form rename compare)
  467.      (define (descend-quasiquote x level return)
  468.        (cond ((pair? x) (descend-quasiquote-pair x level return))
  469.          ((vector? x) (descend-quasiquote-vector x level return))
  470.          (else (return 'QUOTE x))))
  471.      (define (descend-quasiquote-pair x level return)
  472.        (cond ((not (and (pair? x)
  473.                 (identifier? (car x))
  474.                 (pair? (cdr x))
  475.                 (null? (cddr x))))
  476.           (descend-quasiquote-pair* x level return))
  477.          ((compare (rename 'QUASIQUOTE) (car x))
  478.           (descend-quasiquote-pair* x (+ level 1) return))
  479.          ((compare (rename 'UNQUOTE) (car x))
  480.           (if (zero? level)
  481.               (return 'UNQUOTE (cadr x))
  482.               (descend-quasiquote-pair* x (- level 1) return)))
  483.          ((compare (rename 'UNQUOTE-SPLICING) (car x))
  484.           (if (zero? level)
  485.               (return 'UNQUOTE-SPLICING (cadr x))
  486.               (descend-quasiquote-pair* x (- level 1) return)))
  487.          (else
  488.           (descend-quasiquote-pair* x level return))))
  489.      (define (descend-quasiquote-pair* x level return)
  490.        (descend-quasiquote
  491.         (car x) level
  492.         (lambda (car-mode car-arg)
  493.           (descend-quasiquote
  494.            (cdr x) level
  495.            (lambda (cdr-mode cdr-arg)
  496.          (cond ((and (eq? car-mode 'QUOTE) (eq? cdr-mode 'QUOTE))
  497.             (return 'QUOTE x))
  498.                ((eq? car-mode 'UNQUOTE-SPLICING)
  499.             (if (and (eq? cdr-mode 'QUOTE) (null? cdr-arg))
  500.                 (return 'UNQUOTE car-arg)
  501.                 (return 'APPEND
  502.                     (list car-arg
  503.                       (finalize-quasiquote cdr-mode
  504.                                    cdr-arg)))))
  505.                ((and (eq? cdr-mode 'QUOTE) (list? cdr-arg))
  506.             (return 'LIST
  507.                 (cons (finalize-quasiquote car-mode car-arg)
  508.                       (map (lambda (element)
  509.                          (finalize-quasiquote 'QUOTE
  510.                                   element))
  511.                        cdr-arg))))
  512.                ((eq? cdr-mode 'LIST)
  513.             (return 'LIST
  514.                 (cons (finalize-quasiquote car-mode car-arg)
  515.                       cdr-arg)))
  516.                (else
  517.             (return
  518.              'CONS
  519.              (list (finalize-quasiquote car-mode car-arg)
  520.                    (finalize-quasiquote cdr-mode cdr-arg))))))))))
  521.      (define (descend-quasiquote-vector x level return)
  522.        (descend-quasiquote
  523.         (vector->list x) level
  524.         (lambda (mode arg)
  525.           (case mode
  526.         ((QUOTE) (return 'QUOTE x))
  527.         ((LIST) (return 'VECTOR arg))
  528.         (else
  529.          (return 'LIST->VECTOR
  530.              (list (finalize-quasiquote mode arg))))))))
  531.      (define (finalize-quasiquote mode arg)
  532.        (case mode
  533.          ((QUOTE) `(,(rename 'QUOTE) ,arg))
  534.          ((UNQUOTE) arg)
  535.          ((UNQUOTE-SPLICING) (syntax-error ",@ in illegal context" arg))
  536.          (else `(,(rename mode) ,@arg))))
  537.      (if (syntax-match? '(EXPRESSION) (cdr form))
  538.          (descend-quasiquote (cadr form) 0 finalize-quasiquote)
  539.          (ill-formed-syntax form))))
  540.  
  541. ;;; end MAKE-CORE-EXPANDER-MACROLOGY
  542.      )))
  543.